# $Id: dccore.tcl 44 2007-09-03 00:47:25Z khomoutov $
# DirectConnect protocol implementation.

namespace eval ::dccore {
	namespace export connect shutdown callback genkey mediatypeindex

	# types of media for the $Search command.
	# Note that they're indexed from 1 in the protocol,
	# so any = 1 and TTH = 9.
	# This list gets looked up by index, so it must not be sorted,
	# the order is important.
	variable mediatypes {
		any
		audio
		compressed
		documents
		executables
		pictures
		video
		folders
		TTH
		UNKNOWN_TYPE_10
	}
}

# Arguments are that of the [socket] command plus:
# TODO implement async connect with callback on "connected" state
proc ::dccore::connect args {
	set scmd [list socket -async]

	foreach {opt val} $args {
		switch -glob -- $opt {
			-host { set host $val }
			-port { set port $val }
			-myaddr { lappend scmd $opt $val }
			-myport { lappend scmd $opt $val }
			-encoding { set encoding $val }
			-connecttimeout { set timeout $val }
			-async { set conncmd $val }
			default {
				return -code error "unknown option: $opt"
			}
		}
	}

	foreach {var opt} {host -host port -port encoding -encoding} {
		if {![info exists $var]} {
			return -code error "required option missing: $opt"
		}
	}

	lappend scmd $host $port
	set sock [eval $scmd]

	variable $sock
	upvar 0 $sock state

	fileevent $sock writable [mycmd SockConnected $sock]
	if {[info exists timeout]} {
		set state(callback/timeout) [after $timeout [mycmd SockConnectTimedOut $sock]]
	}

	set state(encoding)  $encoding
	set state(connected) false

	if {[info exists conncmd]} {
		set state(callback/connected) $conncmd
	} else {
		vwait [my ${sock}(connected)]

		set connected $state(connected)
		set error     $state(error)
		unset state

		if {!$connected} {
			return -code error $error
		}
	}

	set sock
}

proc ::dccore::SockConnectTimedOut sock {
	variable $sock
	upvar 0 $sock state

	set state(connected) false
	set state(error) "connection timed out"

	SockFinalizeConnection $sock
}

proc ::dccore::SockConnected sock {
	variable $sock
	upvar 0 $sock state

	set state(error)     [fconfigure $sock -error]
	set state(connected) [expr {$state(error) == ""}]

	SockFinalizeConnection $sock
}

proc ::dccore::SockFinalizeConnection sock {
	variable $sock
	upvar 0 $sock state

	fileevent $sock writable {}
	if {[info exists state(callback/timeout)]} {
		after cancel $state(callback/timeout)
	}

	if {$state(connected)} {
		fconfigure $sock -blocking no -buffering none \
			-translation lf -eofchar {} -encoding $state(encoding)
	} else {
		close $sock
	}

	upvar 0 state(callback/connected) callback
	if {[info exists callback]} {
		if {$callback != ""} {	
			namespace eval :: $callback \
				[list $sock $state(connected) $state(error)]
		}

		unset state
	}
}

proc ::dccore::ParseStanza {stanza vcmd vparam} {
	upvar 1 $vcmd cmd $vparam param

	set ix [string first " " $stanza]
	if {$ix >= 0} {
		set cmd   [string range $stanza 0 [expr {$ix - 1}]]
		set param [string trimleft \
			[string range $stanza [expr {$ix + 1}] end]]
	} else {
		set cmd  $stanza
		set param ""
	}
}

proc ::dccore::shutdown sock {
	close $sock

	variable $sock
	if {[info exists $sock]} {
		unset $sock
	}
}

proc ::dccore::command {action sock args} {
	switch -- $action {
		hookonce {
			eval [list HookCommandOnce $sock] $args
		}
		default {
			return -code error "unknown action: $action"
		}
	}
}

proc ::dccore::HookCommandOnce {sock args} {
	variable $sock
	upvar 0 $sock state

	array unset state hookonce,*
	foreach {cmd script} $args {
		set state(hookonce,$cmd) $script
	}
}

# Purpose:
#   Generates a "key" by a given "lock" represented as a "native" Tcl string.
# Input:
#   $lock -- the lock for which to generate the key;
#   $encoding -- must be encoding configured for the socket.
#   $seed -- magic number. 5 for client-to-server,
#     when the key is generated for the hub connecting to a hublist
#     the seed is calculated as ((localport >> 8) + (localport & 255)) & 255
# Output:
#   Generated key as a string.
# Side-effects:
#   None.
# Node:
#   Specification of encoding is needed to transform the lock string
#   back to the "raw" string of 8-bit characters since the key is generated
#   by applying various bitwise transformations to bytes, not characters.
proc ::dccore::genkey {lock encoding {seed 5}} {
	encoding convertfrom $encoding \
		[BinaryGenKey [encoding convertto $encoding $lock] $seed]
}

# Purpose:
#   Generates a "key" by a given "lock" which must be "raw" string
#   of 8-bit characters in the original (socket) charset.
# Input:
#   $lock -- the lock for which to generate the key;
#   $seed -- magic number. 5 for client-to-server,
#     when the key is generated for the hub connecting to a hublist
#     the seed is calculated as ((localport >> 8) + (localport & 255)) & 255
# Output:
#   Generated key as a string.
# Side-effects:
#   None.
proc ::dccore::BinaryGenKey {lock {seed 5}} {
	if {[string length $lock] < 3} {
		return -code error "lock is less than 3 characters long"
	}

	set L [list]
	foreach c [split $lock ""] {
		scan $c %c n
		lappend L $n
	}

	set K [list]
	set n [expr {[lindex $L 0] ^ $seed}]
	lappend K [expr {(($n >> 4) | ($n << 4)) & 255}]

	foreach a [lrange $L 1 end] b [lrange $L 0 end-1] {
		set n [expr {$a ^ $b}]
		lappend K [expr {(($n >> 4) | ($n << 4)) & 255}]
	}

	lset K 0 [expr {[lindex $K 0] ^ [lindex $K end]}]

	string map {
		\u0000    /%DCN000%/
		\u0005    /%DCN005%/
		\u0024    /%DCN036%/
		\u0060    /%DCN096%/
		\u007C    /%DCN124%/
		\u007E    /%DCN126%/
	} [binary format c* $K]
}

# Purpose:
#   Returns "media type index" (as used in the DC protocol to specify
#   types of media to search for) for the given mnemonic of media type
#   (as used in this library).
#   If given media type is not known to the library, this procedure
#   raises an error.
# Input:
#   $mnemonic -- media type to look up.
# Output:
#   Media type index corresponding to the given mnemonic.
# Side-effects:
#   None.
proc ::dccore::mediatypeindex mnemonic {
	variable mediatypes

	set ix [lsearch $mediatypes $mnemonic]
	if {$ix < 0} {
		return -code error "bad media type \"$mnemonic\":\
			must be one of [join $mediatypes {, }]"
	}
	expr {$ix + 1} ;# type indices start from 1, not 0 in DC protocol
}

